-- |
-- Module:        Hexena.
-- Stability:     Experimental
-- Portability:   Portable
--
-- <>
{-# LANGUAGE ForeignFunctionInterface #-}
module Hexena.Cmds.HexView (run) where

import Prelude hiding (flip)
import qualified Data.ByteString.Lazy.Char8 as L8
import Control.Monad.State
import Control.Monad.Reader
import Data.Char (toLower)
import Data.Maybe
import Foreign
import Graphics.UI.SDL
import Graphics.UI.SDL.Image
import H8Bit.BitmapFont
import System.Environment (getArgs)
import Text.Printf

import Hexena.Text.Hexdump

data AppLoopState = AppInit
                  | AppRun
                  | AppQuit
                  deriving (Show)

data AppConsts = AppConsts {
  contents :: L8.ByteString,
  font :: BFBitmapFont
  }
                 
data AppData = AppData {
  screen :: Surface,
  fPos :: Int64,
  myView :: TextArray,
  myRight :: TextArray,
  myStatus :: TextArray
  }

type AppState = StateT AppData IO
type AppEnv = ReaderT AppConsts AppState

displayWidth :: Int
displayWidth = 800 :: Int
displayHeight :: Int
displayHeight = 600 :: Int

eventHandler :: Event -> AppEnv AppLoopState
eventHandler Quit = return AppQuit
eventHandler (KeyDown (Keysym SDLK_ESCAPE _ _)) = return AppQuit
eventHandler (KeyDown (Keysym SDLK_DOWN _ _)) = do
  c <- ask
  get >>= put . f (L8.length $ contents c) >> return AppRun
  where f mx s = s { fPos = if p' >= mx then p else p' }
          where p = fPos s
                p' = 16 + p
eventHandler (KeyDown (Keysym SDLK_UP _ _)) = get >>= put . f >> return AppRun
  where f s = s { fPos = if p > 16 then p - 16 else 0 }
          where p = fPos s
eventHandler (KeyDown (Keysym SDLK_PAGEDOWN _ _)) = do
  c <- ask
  get >>= put . f (L8.length $ contents c) >> return AppRun
  where f mx s = s { fPos = if p' >= mx then p else p' }
          where p = fPos s
                p' = 0x400 + p
eventHandler (KeyDown (Keysym SDLK_PAGEUP _ _)) = get >>= put . f >> return AppRun
  where f s = s { fPos = if p > d then p - d else 0 }
          where p = fPos s
                d = 0x400
eventHandler (KeyDown (Keysym SDLK_HOME _ _)) = get >>= put . (\x -> x { fPos = 0 }) >> return AppRun
eventHandler (KeyDown (Keysym SDLK_END _ _)) = do
  l <- (L8.length . contents) `fmap` ask
  get >>= put . (\s -> s { fPos = l - 0x400 })
  return AppRun
eventHandler (KeyDown (Keysym SDLK_F12 _ _)) = do
  s <- get
  d <- liftIO $ setVideoMode' True
  put $ (\y x -> x { screen = y }) d s
  return AppRun
  --get >>= (setVideoMode' True >>= put . (\y x -> x { screen = y })) >> return AppRun
eventHandler (MouseButtonDown _ _ ButtonWheelDown) = do 
  c <- ask
  get >>= put . f (L8.length $ contents c) >> return AppRun
    where f mx s = s { fPos = if p' >= mx then p else p' }
            where p = fPos s
                  p' = 0x200 + p
eventHandler (MouseButtonDown _ _ ButtonWheelDown) = do 
  c <- ask
  get >>= put . f (L8.length $ contents c) >> return AppRun
    where f mx s = s { fPos = if p' >= mx then p else p' }
            where p = fPos s
                  p' = 0x200 + p
                  
eventHandler (MouseButtonDown _ _ ButtonWheelUp) = get >>= put . f >> return AppRun
  where f s = s { fPos = if p > d then p - d else 0 }
          where p = fPos s
                d = 0x200
-- eventHandler  x = liftIO $ print x >> return AppRun
eventHandler  _ = return AppRun


fullDraw :: [String] -> Surface -> TextArray -> TextArray -> TextArray -> BFBitmapFont -> IO ()
fullDraw hextext s ta tr ts fo = do
  -- _ <- fillRect s Nothing $ Pixel 0 
  _ <- bfDrawText s $ map (\y -> bfChar fo (displayWidth - 176) y '\x0') [8,16..(74*8)]
  _ <- bfDrawText s $ map (\y -> bfChar fo (displayWidth - 8) y '\x0') [8,16..(74*8)]
  _ <- bfDrawText s $ map (\y -> bfChar fo 0 y '\x0') [70*8,71*8..75*8]
  _ <- bfDrawText s $ bfLine fo (displayWidth - 176) 0 "\x0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\x0" -- $ '\x70':(replicate 20 '\0'):'\x0e':[]
  _ <- bfDrawText s $ bfLine fo 0 (displayHeight - 8) $ "\x0" ++ replicate 77 '\0' ++ "\x0" ++ replicate 20 '\0' ++ "\x0"
  _ <- bfDrawText s $ bfLine fo 0 (displayHeight - 8 * 6) $ "\x0" ++ replicate 77 '\0' ++ "\x0"
  taClrScr ta
  mapM_ (taPrintTextLn ta) $ take 67 hextext
  _ <- paintTextArray ta fo s
  _ <- paintTextArray tr fo s
  _ <- paintTextArray ts fo s
  return ()

loop :: AppLoopState -> AppEnv AppLoopState
loop AppQuit = return AppQuit
loop _ = do
  sc <- screen `liftM` get
  fo <- font `liftM` ask
  vi <- myView `fmap` get
  vr <- myRight `fmap` get
  vs <- myStatus `fmap` get
  po <- fPos `fmap` get
  co <- contents `liftM` ask
  liftIO $ do
        fullDraw (hexifyLines po co) sc vi vr vs fo
        _ <- flip sc
        return ()
  loop =<< eventHandler =<< liftIO waitEvent 



runLoop :: AppConsts -> AppData -> IO (AppLoopState, AppData)
runLoop = runStateT . runReaderT (loop AppInit)

foreign import ccall unsafe "get_font" get_font :: IO (Ptr SurfaceStruct)
getFont :: IO (Maybe Surface)
getFont = get_font >>= maybePeek mkFinalizedSurface

convert :: Char -> Int
convert = f . ascii2c64 . toLower
  where f c | c >= 96 = 0x2e
            | otherwise = c

setVideoMode' :: Bool -> IO Surface
setVideoMode' = setVideoMode displayWidth displayHeight 32 . flags
  where flags True = [HWSurface, Fullscreen]
        flags False = [HWSurface]

run :: FilePath -> IO ()
run fn = do
  content <- L8.readFile fn
  -- let content = L8.pack ['\0'..'\xff']
  withInit [InitVideo,InitEventthread] $ do
    _ <- enableKeyRepeat 500 80
    scr <- setVideoMode' False
    setCaption fn "retroHexviewer"
    charset' <- displayFormat =<< fromJust `fmap` getFont --getload "charset64.small.png"
    -- mapRGB (surfaceGetPixelFormat charset') 0x3e 0x31 0xa2 >>= setColorKey charset' [SrcColorKey]
    charset <- bfMakeFont 8 8 convert `fmap` convertSurface charset' (surfaceGetPixelFormat scr) []
    sView <- mkTextArray 0 0 78 69 ' '
    sRight <- mkTextArray (displayWidth - 21 * 8) 8 20 73 ' '
    sStatus <- mkTextArray 8 (displayHeight - 5 * 8) 77 4 ' '
    taPrintTextLn sStatus $ printf "filesize = $%08x" $ L8.length content
    taPrintTextLn sRight "  Retro HexViewer"
    taPrintTextLn sRight $ "  " ++ replicate 15 '\x7e'
    _ <- advanceCursorDown sRight
    taPrintTextLn sRight "ESC  \x5c Quit"
    taPrintTextLn sRight "UP   \x5c Line up"
    taPrintTextLn sRight "DOWN \x5c Line down"
    taPrintTextLn sRight "PGUP \x5c 0x400 up"
    taPrintTextLn sRight "PGDN \x5c 0x400 down"
    taPrintTextLn sRight "HOME \x5c Beginning"
    taPrintTextLn sRight "END  \x5c End of File"
    let c = AppConsts content charset
        d = AppData scr 0 sView sRight sStatus
    _ <- runLoop c d
    return ()
